home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue52 / Alfresco / AASplChk.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-10-31  |  7.6 KB  |  277 lines
  1. {*********************************************************}
  2. {* AASplChk                                              *}
  3. {* Copyright (c) Julian M Bucknall 1999                  *}
  4. {* All rights reserved.                                  *}
  5. {*********************************************************}
  6. {* Algorithms Alfresco spell checker                     *}
  7. {*********************************************************}
  8.  
  9. {Note: this unit is released as freeware. In other words, you are free
  10.        to use this unit in your own applications, however I retain all
  11.        copyright to the code. JMB}
  12.  
  13. unit AASplChk;
  14.  
  15. interface
  16.  
  17. uses
  18.   SysUtils,
  19.   Classes;
  20.  
  21. type
  22.   TaaSoundex = string[4];
  23.   PaaWordStr = ^TaaWordStr;
  24.   TaaWordStr = string[255];
  25.  
  26. type
  27.   TaaSpellChecker = class
  28.     private
  29.       FWordTable    : TList;
  30.       FSoundexTable : TList;
  31.       FWordCount    : longint;
  32.     protected
  33.       procedure scAddWordEntry(const aWord : PaaWordStr);
  34.       procedure scAddSoundexEntry(const aSoundex : TaaSoundex;
  35.                                         aWord    : PaaWordStr);
  36.       procedure scBuildTables(const aWordListFile : string);
  37.       procedure scFreeTables;
  38.  
  39.     public
  40.       constructor Create(const aWordListFile : string);
  41.       destructor Destroy; override;
  42.  
  43.       function WordExists(aWord : string) : boolean;
  44.       procedure GetAlternatives(const aWord : string;
  45.                                       aList : TStrings);
  46.  
  47.       property WordCount : longint read FWordCount;
  48.   end;
  49.  
  50. function AASoundex(const aWord : string) : TaaSoundex;
  51.  
  52. implementation
  53.  
  54. {===Soundex function=================================================}
  55. function AASoundex(const aWord : string) : TaaSoundex;
  56. const
  57.   Encode : array ['A'..'Z'] of char =
  58.            ('0', '1', '2', '3', '0', '1', '2', '/', '0', '2', '2',
  59.             '4', '5', '5', '0', '1', '2', '6', '2', '3', '0', '1',
  60.             '/', '2', '0', '2');
  61. var
  62.   Ch : char;
  63.   Code, OldCode : char;
  64.   SxInx : integer;
  65.   i     : integer;
  66. begin
  67.   Result := 'A000';
  68.   if (aWord = '') then
  69.     raise Exception.Create('Soundex: input string is empty');
  70.   Ch := UpCase(aWord[1]);
  71.   if not ('A' <= Ch) and (Ch <= 'Z') then
  72.     raise Exception.Create('Soundex: unknown character in input string');
  73.   Result[1] := Ch;
  74.   Code := Encode[Ch];
  75.   OldCode := Code;
  76.   SxInx := 2;
  77.   for i := 2 to length(aWord) do begin
  78.     if (Code <> '/') then
  79.       OldCode := Code;
  80.     Ch := UpCase(aWord[i]);
  81.     if not ('A' <= Ch) and (Ch <= 'Z') then
  82.       Code := '0'
  83.     else
  84.       Code := Encode[Ch];
  85.     if (Code <> OldCode) and (Code > '0') then begin
  86.       Result[SxInx] := Code;
  87.       inc(SxInx);
  88.       if (SxInx > 4) then
  89.         Break;
  90.     end;
  91.   end;
  92. end;
  93. {====================================================================}
  94.  
  95.  
  96. {====================================================================}
  97. function AllocWordString(const aWord : string) : PaaWordStr;
  98. begin
  99.   GetMem(Result, succ(length(aWord)));
  100.   Result^ := aWord;
  101. end;
  102. {--------}
  103. procedure FreeWordString(aWord : PaaWordStr);
  104. begin
  105.   FreeMem(aWord, succ(length(aWord^)));
  106. end;
  107. {--------}
  108. function LowCase(Ch : char) : char;
  109. begin
  110.   if ('A' <= Ch) and (Ch <= 'Z') then
  111.     Result := char(ord(Ch) + (ord('a') - ord('A')))
  112.   else
  113.     Result := Ch;
  114. end;
  115. {====================================================================}
  116.  
  117.  
  118. {===Hash algorithms==================================================}
  119. function CalcELFHash(const S : string) : longint;
  120. var
  121.   G : longint;
  122.   i : integer;
  123. begin
  124.   Result := 0;
  125.   for i := 1 to length(S) do begin
  126.     Result := (Result shl 4) + ord(S[i]);
  127.     G := Result and longint($F0000000);
  128.     if (G <> 0) then
  129.       Result := Result xor (G shr 24);
  130.     Result := Result and (not G);
  131.   end;
  132. end;
  133. {--------}
  134. function CalcSoundexHash(const S : TaaSoundex) : integer;
  135. begin
  136.   Result := ((ord(S[1]) - ord('A')) * 343) +
  137.             ((ord(S[2]) - ord('0')) * 49) +
  138.             ((ord(S[3]) - ord('0')) * 7) +
  139.              (ord(S[4]) - ord('0'));
  140. end;
  141. {====================================================================}
  142.  
  143.  
  144. {===TaaSpellChecker==================================================}
  145. const
  146.   WordTableSize = 10007; {a prime}
  147.   SoundexTableSize = 26*7*7*7; {the exact number of Soundexes}
  148. {--------}
  149. constructor TaaSpellChecker.Create(const aWordListFile : string);
  150. begin
  151.   inherited Create;
  152.   FWordTable := TList.Create;
  153.   FWordTable.Count := WordTableSize;
  154.   FSoundexTable := TList.Create;
  155.   FSoundexTable.Count := SoundexTableSize;
  156.   scBuildTables(aWordListFile);
  157. end;
  158. {--------}
  159. destructor TaaSpellChecker.Destroy;
  160. begin
  161.   scFreeTables;
  162.   inherited Destroy;
  163. end;
  164. {--------}
  165. procedure TaaSpellChecker.GetAlternatives(const aWord : string;
  166.                                                 aList : TStrings);
  167. var
  168.   Soundex : TaaSoundex;
  169.   Hash    : integer;
  170.   i       : integer;
  171.   ThisList: TList;
  172. begin
  173.   if not Assigned(aList) then
  174.     Exit;
  175.   aList.Clear;
  176.   Soundex := AASoundex(aWord);
  177.   Hash := CalcSoundexHash(Soundex);
  178.   if (FSoundexTable[Hash] <> nil) then begin
  179.     ThisList := TList(FSoundexTable[Hash]);
  180.     for i := 0 to pred(ThisList.Count) do
  181.       aList.Add(PaaWordStr(ThisList[i])^);
  182.   end;
  183. end;
  184. {--------}
  185. procedure TaaSpellChecker.scAddSoundexEntry(const aSoundex : TaaSoundex;
  186.                                                   aWord    : PaaWordStr);
  187. var
  188.   Hash : integer;
  189. begin
  190.   Hash := CalcSoundexHash(aSoundex);
  191.   if FSoundexTable[Hash] = nil then
  192.     FSoundexTable[Hash] := TList.Create;
  193.   TList(FSoundexTable[Hash]).Add(aWord);
  194. end;
  195. {--------}
  196. procedure TaaSpellChecker.scAddWordEntry(const aWord : PaaWordStr);
  197. var
  198.   Hash : longint;
  199. begin
  200.   Hash := CalcELFHash(aWord^) mod WordTableSize;
  201.   if FWordTable[Hash] = nil then
  202.     FWordTable[Hash] := TList.Create;
  203.   TList(FWordTable[Hash]).Add(aWord);
  204. end;
  205. {--------}
  206. procedure TaaSpellChecker.scBuildTables(const aWordListFile : string);
  207. var
  208.   F : text;
  209.   TheWord : TaaWordStr;
  210.   OurWord : PaaWordStr;
  211.   Soundex : TaaSoundex;
  212.   i       : integer;
  213. begin
  214.   System.Assign(F, aWordListFile);
  215.   System.Reset(F);
  216.   try
  217.     repeat
  218.       readln(F, TheWord);
  219.       for i := 1 to length(TheWord) do
  220.         TheWord[i] := LowCase(TheWord[i]);
  221.       OurWord := AllocWordString(TheWord);
  222.       scAddWordEntry(OurWord);
  223.       Soundex := AASoundex(TheWord);
  224.       scAddSoundexEntry(Soundex, OurWord);
  225.     until EOF(F);
  226.   finally
  227.     System.Close(F);
  228.   end;
  229. end;
  230. {--------}
  231. procedure TaaSpellChecker.scFreeTables;
  232. var
  233.   i, j : integer;
  234.   ThisList : TList;
  235. begin
  236.   if (FSoundexTable <> nil) then begin
  237.     for i := 0 to pred(SoundexTableSize) do
  238.       TList(FSoundexTable[i]).Free;
  239.     FSoundexTable.Free;
  240.   end;
  241.   if (FWordTable <> nil) then begin
  242.     for i := 0 to pred(WordTableSize) do begin
  243.       ThisList := TList(FWordTable[i]);
  244.       if Assigned(ThisList) then begin
  245.         for j := 0 to pred(ThisList.Count) do
  246.           FreeWordString(PaaWordStr(ThisList[j]));
  247.         TList(FWordTable[i]).Free;
  248.       end;
  249.     end;
  250.     FWordTable.Free;
  251.   end;
  252. end;
  253. {--------}
  254. function TaaSpellChecker.WordExists(aWord : string) : boolean;
  255. var
  256.   i    : integer;
  257.   Hash : longint;
  258.   ThisList : TList;
  259. begin
  260.   Result := false;
  261.   for i := 1 to length(aWord) do
  262.     aWord[i] := LowCase(aWord[i]);
  263.   Hash := CalcELFHash(aWord) mod WordTableSize;
  264.   if (FWordTable[Hash] = nil) then
  265.     Exit;
  266.   ThisList := TList(FWordTable[Hash]);
  267.   for i := 0 to pred(ThisList.Count) do begin
  268.     if (CompareText(PaaWordStr(ThisList[i])^, aWord) = 0) then begin
  269.       Result := true;
  270.       Exit;
  271.     end;
  272.   end;
  273. end;
  274. {====================================================================}
  275.  
  276. end.
  277.